Personal Computer World 2005 October/PCWOCT05.iso/Software/FromTheMag/Syn Text Editor 2.1.0.46/synsetup-2.1.0.46.exe/{app}/scripts/cmnfunc.vbs

Text File | 2003-08-13 | 11.9 KB | 436 lines

'
'  syn
'  Copyright (C) 2000-2003, Ascher Stefan. All rights reserved.
'  [e-mail], http://web.utanet.at/ascherst/
'
'  The contents of this file are subject to the Mozilla Public License
'  Version 1.1 (the "License"); you may not use this file except in compliance
'  with the License. You may obtain a copy of the License at
'  http://www.mozilla.org/MPL/
'
'  Software distributed under the License is distributed on an "AS IS" basis,
'  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
'  the specific language governing rights and limitations under the License.
'
'  The Original Code is cmnfunc.vbs, released Sun, 26 May 2002 10:55:39 UTC.
'
'  The Initial Developer of the Original Code is Ascher Stefan.
'  Portions created by Ascher Stefan are Copyright (C) 2000-2003 Ascher Stefan.
'  All Rights Reserved.
'
'  Contributor(s): .
'
'  Alternatively, the contents of this file may be used under the terms of the
'  GNU General Public License Version 2 or later (the "GPL"), in which case
'  the provisions of the GPL are applicable instead of those above.
'  If you wish to allow use of your version of this file only under the terms
'  of the GPL and not to allow others to use your version of this file
'  under the MPL, indicate your decision by deleting the provisions above and
'  replace them with the notice and other provisions required by the GPL.
'  If you do not delete the provisions above, a recipient may use your version
'  of this file under either the MPL or the GPL.
'
'  You may retrieve the latest version of this file at the syn home page,
'  located at http://syn.sourceforge.net/
'
' $Id: cmnfunc.vbs,v 1.9.2.5 2003/08/13 00:38:45 neum Exp $

' This file contains often used functions and procedures. You can include this
' file only in a VBScript Macro, but you may translate it into your favourite
' Language.

function IIf(Expr, TruePart, FalsePart)
  ' returns the TruePart when Expr evaluates to True
  if Expr then
    IIf = TruePart
  else
    IIf = FalsePart
  end if
end function

' File/Directory procedures
function FileExists(FileName)
  dim objFs
  set objFs = CreateObject("Scripting.FileSystemObject")
  FileExists = objFs.FileExists(FileName)
end function

function DirExists(DirName)
  dim objFs
  set objFs = CreateObject("Scripting.FileSystemObject")
  DirExists = objFs.FolderExists(DirName)
end function

sub DeleteFile(FileName)
  dim objFile, objFs
  set objFs = CreateObject("Scripting.FileSystemObject")
  set objFile = objFs.GetFile(FileName)
  objFile.Delete
end sub

sub DeleteDir(DirName)
  dim objFs
  set objFs = CreateObject("Scripting.FileSystemObject")
  objFs.DeleteFolder DirName, true
end sub

function Execute(CmdLine, Show, Wait)
  dim objShell
  set objShell = CreateObject("WScript.Shell")
  Execute = objShell.Run(CmdLine, Show, Wait)
end function

function AddBackslash(DirName)
  ' adds a trailing backslash
  if Right(DirName, 1) <> "\" then
    AddBackslash = DirName & "\"
  else
    AddBackslash = DirName
  end if
end function

function RemoveBackslash(DirName)
  ' removes a trailing backslash
  if Right(DirName, 1) <> "\" then
    RemoveBackslash = DirName
  else
    RemoveBackslash = Left(DirName, Len(DirName) - 1)
  end if
end function

function AddSlash(DirName)
  ' adds a trailing backslash
  if Right(DirName, 1) <> "/" then
    AddSlash = DirName & "/"
  else
    AddSlash = DirName
  end if
end function

function RemoveSlash(DirName)
  ' removes a trailing backslash
  if Right(DirName, 1) <> "/" then
    RemoveSlash = DirName
  else
    RemoveSlash = Left(DirName, Len(DirName) - 1)
  end if
end function

function RemoveFilename(FileName)
  dim Char
  RemoveFilename = FileName
  while (Char <> "\") and (Len(RemoveFilename) > 0)
    Char = Right(RemoveFilename, 1)
    if Char <> "\" then
      RemoveFilename = Left(RemoveFilename, Len(RemoveFilename) - 1)
    end If
  wend
end function

function ExtractFilePath(FileName)
  ' returns only the path from a full qualified filename without trailing
  ' backslash
  dim p
  p = RemoveFileName(FileName)
  ExtractFilePath = RemoveBackSlash(p)
end function

function ExtractFilename(FileName)
  ' Removes the path from a full qualified filename
  ExtractFilename = Right(FileName, Len(FileName) - Len(RemoveFilename(FileName)))
end function

function ShortFileName(FileName)
  dim fso, f
  set fso = CreateObject("Scripting.FileSystemObject")
  set f = fso.GetFile(FileName)
  ShortFileName = f.ShortName
end function

function ShortPathName(PathName)
  dim fso, f
  set fso = CreateObject("Scripting.FileSystemObject")
  set f = fso.GetFile(PathName)
  ShortFileName = f.ShortPath
end function

function GetAbsoluteFile(BaseFile, FileName)
  dim tmp
  dim fso, f
  tmp = Curdir
  CurDir = ExtractFilePath(BaseFile)
  set fso = CreateObject("Scripting.FileSystemObject")
  GetAbsoluteFile = fso.GetAbsolutePathName(ExtractFilePath(FileName))
  GetAbsoluteFile = AddBackslash(GetAbsoluteFile) & ExtractFileName(FileName)
  CurDir = tmp
end function

function GetAbsolutePath(BasePath, PathName)
  dim tmp
  dim fso, f
  tmp = Curdir
  CurDir = BasePath
  set fso = CreateObject("Scripting.FileSystemObject")
  GetAbsolutePath = fso.GetAbsolutePathName(PathName)
  CurDir = tmp
end function

function TempFile
  ' returns a unique filename in the temporary folder
  dim fso
  set fso = CreateObject("Scripting.FileSystemObject")
  dim tfolder
  const TemporaryFolder = 2
  set tfolder = fso.GetSpecialFolder(TemporaryFolder)
  TempFile = AddBackslash(tfolder.Path) & fso.GetTempName
end function

function ChangeFileExt(FileName, Ext)
  ' note: the dot belongs to the file extension
  dim tmp
  tmp = FileName
  while (Right(tmp, 1) <> ".") and (tmp <> "")
    tmp = Left(tmp, Len(tmp) - 1)
  wend
  if tmp = "" then
    ChangeFileExt = FileName & Ext
  else
    tmp = Left(tmp, Len(tmp) - 1)
    ChangeFileExt = tmp & Ext
  end if
end function

function ExtractFileExt(FileName)
  ' Returns the file extension from a file _with_ the dot, because see above
  dim tmp
  tmp = FileName
  while (Right(tmp, 1) <> ".") and (tmp <> "")
    tmp = Left(tmp, Len(tmp) - 1)
  wend
  if tmp = "" then
    ExtractFileExt = ""
  else
    ExtractFileExt = Right(FileName, Len(FileName) - Len(tmp) + 1)
  end if
end function

' Common Dialogs
function GetSaveFileName(FileName, Filter, DefExt, InitDir, Title, Options)
  ' True -> OK
  ' False -> Cancel
  ' FileName returns the chosen filename
  GetSaveFileName = false
  with Create("TSaveDialog", Self)
    .Title = Title
    .InitialDir = InitDir
    .DefaultExt = DefExt
    .Filter = Filter
    .FileName = FileName
    if Options <> "" then
      .Options = Options
    end if
    if .Execute then
      FileName = .FileName
      GetSaveFileName = true
    end if
    .Free
  end with
end function

function GetOpenFileName(FileName, Filter, DefExt, InitDir, Title, Options)
  ' Same as above
  GetOpenFileName = false
  with Create("TOpenDialog", Self)
    .Title = Title
    .InitialDir = InitDir
    .DefaultExt = DefExt
    .Filter = Filter
    .FileName = FileName
    if Options <> "" then
      .Options = Options
    end if
    if .Execute then
      FileName = .FileName
      GetOpenFileName = true
    end if
    .Free
  end with
end function

function BrowseForFolder(strPrompt, BrowseInfo, Root)
  ' Shows the Browse for Folder Dialog
  ' It seems you need the new Shell32.dll or something to get it to work, anyway,
  ' it does not work on my machine.
  dim objShell, objFolder, intColonPos, objWshShell
  on error resume next
  set objShell = CreateObject("Shell.Application")
  if Err <> 0 then
    MsgBox "Error " & Err & ": " & Err.Description, vbCritical
    exit function
  end if
  set objFolder = objShell.BrowseForFolder(&H0, strPrompt, BrowseInfo, Root)
  BrowseForFolder = objFolder.ParentFolder.ParseName(objFolder.Title).Path
  if Err <> 0 then
    MsgBox Err
    if Err = 424 then
      'Invalid Folder or Cancel
      BrowseForFolder = ""
    else
      MsgBox "Error " & Err & ": " & Err.Description, vbCritical
    end if
  end if
end function

' Environment Variables
function GetEnv(VarName)
  ' Returns an Environment variable for the current process
  dim objShell, objSysEnv
  set objShell = CreateObject("WScript.Shell")
  set objSysEnv = objShell.Environment("PROCESS")
  GetEnv = objSysEnv(VarName)
end function

sub SetEnv(VarName, Value)
  ' Sets an Environment variable for the current process
  dim objShell, objSysEnv
  set objShell = CreateObject("WScript.Shell")
  set objSysEnv = objShell.Environment("PROCESS")
  objSysEnv(VarName) = Value
end sub

' Misc
function AddQuotesUnless(s)
  ' Adds Quotes when it contains a Space and is not already quoted
  dim q
  q = Chr(34)
  AddQuotesUnless = Trim(s)
  if (InStr(AddQuotesUnless, " ") <> 0) and ((Left(AddQuotesUnless, 1) <> q) or (Right(AddQuotesUnless, 1) <> q)) then
    AddQuotesUnless = q & AddQuotesUnless & q
  end if
end function

function AddQuotes(s)
  ' Adds Quotes in any way
  dim q
  q = Chr(34)
  AddQuotes = q & s & q
end function

function RemoveQuotes(s)
  dim q
  q = Chr(34)
  RemoveQuotes = s
  while (RemoveQuotes <> "") and (Left(RemoveQuotes, 1) = q)
    RemoveQuotes = Right(RemoveQuotes, Len(RemoveQuotes) - 1)
  wend
  while (RemoveQuotes <> "") and (Right(RemoveQuotes, 1) = q)
    RemoveQuotes = Left(RemoveQuotes, Len(RemoveQuotes) - 1)
  wend
end function

' Pascal String Procs
sub Delete(s, index, count)
  dim l, r
  l = Left(s, index - 1)
  r = Mid(s, index + count, Len(s) - (index + count) + 1)
  s = l & r
end sub

sub Insert(source, s, index)
  dim l, r
  l = Left(source, index)
  r = Mid(source, index + 1, Len(source) - index + 1)
  source = l & s & r
end sub

sub StringToFile(String_, FileName)
  dim fso, f
  set fso = CreateObject("Scripting.FileSystemObject")
  set f = fso.CreateTextFile(FileName, true)
  f.Write(String_)
  f.Close
end sub

sub FileWriteLine(String_, FileName, Line)
  const ForWriting = 2
  dim fso, f, i, ts
  set fso = CreateObject("Scripting.FileSystemObject")
  set f = fso.GetFile(FileName)
  set ts = f.OpenAsTextStream(ForWriting, -1)
  while (i < Line) or (not f.AtEndOfStream)
    ts.SkipLine
  wend
  ts.WriteLine(String_)
  ts.Close
end sub

function FileToString(FileName)
  const ForReading = 1
  Dim fso, f
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set f = fso.OpenTextFile(FileName, ForReading)
  FileToString = f.ReadAll
end function

function FileReadLine(FileName, Line)
  const ForReading = 1
  Dim fso, f, i, ts
  Set fso = CreateObject("Scripting.FileSystemObject")
  set f = fso.GetFile(FileName)
  set ts = f.OpenAsTextStream(ForReading, -2)
  while i < Line
    if ts.AtEndOfStream then
      FileReadLine = ""
      exit function
    end if
    ts.SkipLine
  wend
  FileReadLine = ts.ReadLine
  ts.Close
end function

' Registry
function RegGetSettings(Key, Default)
  dim wsh
  set wsh = CreateObject("WScript.Shell")
  on error resume next
  RegGetSettings = wsh.RegRead(Key)
  if Err <> 0 then
    ' Value does not exist, probably
    RegGetSettings = Default
  end if
end function

sub RegSetSettings(Key, Value)
  dim wsh
  set wsh = CreateObject("WScript.Shell")
  wsh.RegWrite Key, Value
end sub

sub RegDelSettings(Key)
  dim wsh
  set wsh = CreateObject("WScript.Shell")
  wsh.RegDelete Key
end sub

function RegValueExists(Key)
  dim wsh, dummy
  set wsh = CreateObject("WScript.Shell")
  on error resume next
  dummy = wsh.RegRead(Key)
  RegValueExists = (Err = 0)
end function

' Misc
function CheckSave
  ' Asks to save modified files
  dim i, m
  CheckSave = true
  for i = 0 to Documents.Count - 1
    if Documents(i).Modified then
      CheckSave = Documents.SaveAll(true)
      exit for
    end if
  next
end function